COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(* $A+,D+*)
C00012 ENDMK
C⊗;
(* $A+,D+*)

program	PALINDROME(OUTPUT);

const	NUMMAX = 5; PALMAX = 100;  NUMLIM = 6; PALLIM = 101;
	TABMAX = 300;  TABLIM = 301;  DISMAX = 100;  DISLIM = 101;

var I, J, K, L, N, TABL, NMAX, NMIN, NUMVAL, PALTOT, PALVAL, CARRY : integer;
    NUM : array [1..NUMLIM] of integer;
    PAL, PAL2 : array [1..PALLIM] of integer;
    TAB, TABN : array [1..TABLIM] of integer;
    DIST : array [0..DISLIM] of integer;
    TEMP : array [1..5] of integer;

begin
for I := 1 TO PALMAX do PAL[I] := 0;
for I := 1 to NUMMAX do NUM[I] := 0;
for I := 1 to TABMAX do
    begin
    TAB[I] := 0; TABN[I] := 0;		(* Exceptions and counts *)
    end;
PALTOT := 0;				(* Count of number of palindromes *)
NMIN := 500;				(* minimun adds for intransigents *)
for I := 0 to DISMAX do DIST[I] := 0;	(* Distribution count *)
NUM [2] := 1; NUMVAL := 2;		(* Initial conditions *)
writeln (OUTPUT,
	'  Palindrome formation tested to a maximum of',PALMAX:4,' digits');
writeln (TTY,
	'  Palindrome formation with repeated additions to maximum of',
	PALMAX:4,' digits'); BREAK;
writeln (OUTPUT);
TABL := TABMAX;
while NUMVAL <= NUMMAX do
    begin (*while NUMVAL <= NUMMAX*)
    I := 1; J := NUMVAL;
    while (NUM[I] = NUM[J]) and (I < J) DO
    begin
	I := I + 1;  J := J - 1;
    end;
    if I >= J then
	begin			(* An initial palindrome *)
	DIST[0] := DIST[0] + 1;	(* with 0 additions *)
	PALTOT := PALTOT + 1;	(* add to palintdome count *)
	PALVAL := PALMAX + 1;	(* To by-pass further testing *)
	end
    else
	begin			(* Not a palindrome initially *)
	PALVAL := NUMVAL;
	K := 0;  I := 1; J := NUMVAL;
	while I < J do
	    begin               (* Compute TAB entry value *)
	    K := (K * 100) + NUM[I] + NUM[J];
	    I := I + 1;  J := J -1;
	    end;
	if I = J then  K := K * 100 + NUM[I];
	I := 1;
	while (I <= TABMAX) and (TAB[I] <> 0) and (PALVAL <> PALMAX + 1) do
	    begin
	    if K = TAB[I] then
		begin
		TABN[I] := TABN[I] + 1;     (* Add count to old category*)
		PALVAL := PALMAX +1;        (* Signal a found category *)
		end
	    else I := I + 1;
	    end;

	if TAB[I] = 0 then 
	    begin                           (* not a found category *)
	    TABL := I;                     (* Hold TAB location *)
	    PALVAL := NUMVAL;               (* Reset PAL length *)
	    N := 0;                         (* To count number of additions *)
	    for I := 1 to NUMVAL do PAL[I] := NUM[I];
	    for I := NUMVAL + 1 TO PALMAX do PAL[I] := 0;
	    end;    (* not a found category *)
	end;			(* not an initial palindrome or a known category*)
    while PALVAL <= PALMAX do
	begin (* while PALVAL <= PALMAX*)
	I := 1; J := PALVAL;
	while ((PAL[I] = PAL [J]) and (I < J)) do
	    begin
	    I := I + 1;  J := J - 1;
	    end;
	if I < J then       (* Not a palindrome*)
	    begin
	    J := PALVAL; CARRY := 0;
	    for I := 1 to PALVAL do
		begin           (* Add number to self with digits reversed *)
		PAL2[I] := PAL[I] + PAL[J] + CARRY;
		if PAL2[I] > 9 then
		    begin
		    PAL2[I] := PAL2[I] - 10;  CARRY := 1;
		    end
		else CARRY := 0;
		J := J - 1;
		end;
	    if CARRY = 1 then
		begin
		PALVAL := PALVAL +1; PAL2[PALVAL] := 1;  CARRY := 0;
		end;
	    if PALVAL = PALMAX + 1  then        (* Limit on depth*)
		begin                           (* One to report*)
		if N < NMIN then NMIN := N;
		TAB[TABL] := K;  TABN[TABL] := 1;
		N := 0;		(* We are through with this N *)
		writeln (TTY,K:10,PALTOT:10); BREAK;
						 (* Report new category*)

		end                     (* of one to report*)
	    else
		begin                   (* Try another addition*)
		for I := 1 to PALVAL do PAL[I] := PAL2[I];
		N := N +1;
		end
	    end
	else
	    begin           (* A palindrome has been found*)
	    DIST[N] := DIST[N] + 1;     (* Addition distribution *)
	    if N > NMAX then NMAX := N;
	    PALTOT := PALTOT + 1; 
	    PALVAL := PALMAX +1;   (* To effect exit from while PALVAL < PALMAX*)
	    end (* a palindrome has been found*)
    end (* while PALVAL <= PALMAX*);

    N := 0;
    CARRY := 1;
    for I := 1 to NUMVAL do
	begin
	NUM[I] := NUM[I] +CARRY;
	if NUM[I] > 9 then
	    begin
	    NUM[I] := 0;
	    CARRY := 1;
	    end
	else CARRY := 0;
	end;
    if CARRY = 1 then		(* Report results and increase NUMVAL *)
	begin
	writeln (OUTPUT,'DATA FOR',NUMVAL:2,'-DIGIT DECIMAL NUMBERS');
	writeln(OUTPUT);
	I := 1;
	L := 0;
	while ((I <= TABMAX) and (TAB[I] <> 0)) do
	    begin
	    L := L + TABN[I];
	    I := I + 1;
	    end;
	writeln (OUTPUT,NMAX:6,' MAX ADDS for',PALTOT:6,' PALINDROMES, with',
		L:5,' INTRANSIGENT CASES');
	writeln(OUTPUT);
	writeln (TTY,'NMAX = ',NMAX:2,'  PALTOT = ',PALTOT:8); BREAK;
	J := 0;
	writeln(OUTPUT,'           Palindromes Found');
	writeln(OUTPUT);
	writeln(OUTPUT,
	    '      FOUND  #ADDS   FOUND  #ADDS   FOUND  #ADDS   FOUND  #ADDS');
	for I := 0 to DISMAX do 
	    begin
	    if DIST[I] <> 0 then
		begin
		write (OUTPUT, DIST[I]:11,I:4);
		J := J +1;  if (J mod 4) = 0 then writeln(OUTPUT);
		end;
	    end;
	writeln (OUTPUT);
	writeln (OUTPUT);
	if TAB[1] = 0 then writeln (OUTPUT,'   No INTRANSIGENT CASES')
	else 
	    begin
	    writeln (OUTPUT,
	'    INTRANSIGENT CASES TO',NMIN:4,' ADDITIONS AND ',PALMAX:3,' DIGITS');
	    writeln (OUTPUT);
	    NMIN := 500;
	    N := (NUMVAL div 2);
	    for L := 1 to N do write (OUTPUT,'  SUM',L:1);
	    if (NUMVAL MOD 2) = 1 then
		begin
		N := N + 1;
	        write (OUTPUT,'  MID#');
		end;
	    writeln (OUTPUT,'   # CASES');
	    I := 1;
	    while ((I <= TABMAX) and (TAB[I] <> 0)) do
		begin
		for L := N downto 1 do
		    begin
		    TEMP[L] := TAB[I] mod 100;
		    TAB[I] := TAB[I] div 100;
		    end;
		for L := 1 to N do write (OUTPUT, TEMP[L]:6);
		writeln (OUTPUT, TABN[I]:8);
		I := I + 1;
		end;
	    end;
	writeln (OUTPUT);
	for I := 1 to TABMAX do
	    begin
	    TAB[I] := 0;
	    TABN[I] := 0;
	    end;
	for I := 0 to DISMAX do DIST[I] := 0;	(* Distribution count *)
	PALTOT := 0;
	NMAX := 0;
	NUMVAL := NUMVAL +1;
	NUM[NUMVAL] := 1;
	CARRY := 0;
	end;

    end (*while NUMVAL <= NUMMAX*);
end.